(define-imported-class (undefined-variable-exception (object offender)) meta-exception)
(define-imported-class (bad-procedure-exception (object offending-procedure)) meta-exception)

;;;
;;; FORWARD REFERENCES
;;;

(%import-object 'missing-value "System.Reflection.Missing.Value" object-type)
(define-imported-class expression object)
(define-imported-class member-reference expression)
(define-imported-class user-procedure procedure
  (define source-expression (public) expression)
  (define (set-documentation (string doc)) (public) void))
(define-imported-class generic-procedure procedure)

(import-static (warn-redefining-generic-procedure "Utilities.WarnRedefiningGeneric"
						  (proc (object) void)))

(define-imported-class (i-object-reference "System.Runtime.Serialization.IObjectReference") object
  (define (get-real-object "System.Runtime.Serialization.IObjectReference.GetRealObject"
			   (streaming-context context))
    (public) object))

(define object-array (type-expression-value '(array object)))

(import-static (placeholder-array "RemoteDataPlaceholder.PlaceholderArray"
				  (proc (object-array)
					object-array)))

(define-imported-class variable expression)
(define-imported-class local-variable variable
  (define index (public) integer))
(define-imported-class global-variable variable
  (define defined? (public) boolean)
  (define value (public) object))
(define-imported-class namespace-base object
  (define (lookup (symbol name)
		  (boolean search)
		  (boolean create)
		  (boolean private))
    (public) global-variable))

(define-imported-class (environment (user-procedure closure)
				    ((array object) env-data)
				    (object parent)
				    (integer snl))
  object
  (define closure (public readonly) user-procedure)
  (define parent (public readonly) environment)
  (define env-data "data" (public readonly) (array object))
  (define snl (public readonly) integer)

  (define (env-lookup (integer index) (integer vsnl)) (public) object)

  (define (env-set! (integer index) (integer vsnl) (object newval))
    (public) object))

(import-static (resolve-namespace "Loader.ResolveNamespace"
				  (proc (string) object))
	       (resolve-global "Loader.ResolveGlobal"
			       (proc (object string) object)))

(define-imported-class file-token object)

(define-imported-class application expression)
(define-imported-class (tail-call (expression function)
				  ((array expression) args))
  application)
(define-imported-class (method-call (expression f)
				    ((array expression) args))
  application)
(define-imported-class (application-general (expression f)
					    ((array expression) args))
  application)
(define-imported-class (application-0 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-1 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-2 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-3 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-4 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-5 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-6 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-7 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-8 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-9 (expression f)
				      ((array expression) args))
  application)
(define-imported-class (application-10 (expression f)
				       ((array expression) args))
  application)

(import (throw! "EvalStack.Throw"
		(proc (exception object object) void))
	(maybe-import "Utilities.MaybeImportVariable"
		      (proc ((type-expression-value 'global-variable)) object)))

(%import-object 'current-source-file
		"TopLevel.CurrentSourceFileToken"
		string-type)
(%import-object 'current-source-definition
		"TopLevel.CurrentSourceDefinition"
		string-type)

(%import-object 'optimize-tail-calls-kluge
		"Expression.OptimizeTailCalls.Value"
		object-type)


(import-static (reference-equals? "Object.ReferenceEquals"
				  (proc (object object) boolean)))

(define arg-local-names
  '(arg0 arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10
	 arg11 arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 arg20))

(define-macro (make-application-class name return-value)
  `(define-class (,name function arguments) application
     ("[Serializable]")
     (define (initialize! this) (public void)
       (base-initializer this))

     (define (eval e env estack)
       ;; Set up stack frame
       (now-evaluating estack e env
         (eval-preamble e env)
	 ;; Determine function to evaluate
	 (let ((op (eval (function e) env estack)))
	   (unless (is? op procedure)
	     (throw! (bad-procedure-exception op)
		     e env))
	   (let ((proc (cast procedure op))
		 (args (arguments e)))
	     ;; Pause if breaking.
;	     (when (and (breakpoint proc)
;			;; No point breaking if we already did.
;			(not (or single-step-mode?
;				 (breakpoint? e))))
;	       (break))
	     (let (,@(map (lambda (n)
			    (list (list-ref arg-local-names n)
				  `(begin ;(set-expression! estack e env)
					  (eval (vector-ref args ,n)
						env
						estack))))
			  (cddr return-value)))
	       (set-expression! estack e env)
	       ;; Do the application
	       (let ((return-value (,(car return-value)
				    proc
				    estack
				    ,@(map (lambda (n)
					     (list-ref arg-local-names n))
					     ;`(eval (vector-ref args ,n)
						;    env
						 ;   estack))
					   (cddr return-value)))))
		 ;; Show the return value, if necessary
		 (when (or (breakpointed-frame? estack)
			   (not (check-normal-2 (exp-execution-mode e)
						(proc-execution-mode proc))))
		   (break (return-value-placeholder return-value e)
			   env))
;		   (push-eval-stack	;the-eval-stack
;		    (constant return-value)
;		    env)
;		   (break e env)
;		   (pop-eval-stack))	; the-eval-stack))
		 ;; return the return value.
		 return-value)
	       )
	       ))))))

(define-module (lisp expression)
  ;;;
  ;;; EXPRESSIONS
  ;;;

  (define-class expression object
    ("[Serializable]")
    ;;
    ;; STATIC MEMBERS
    ;;
    (define optimize-tail-calls-fluid "OptimizeTailCalls"
      (public static readonly fluid) (file-fluid s-all))

    (define (findable-expression (object x)) (public static expression)
      (let ((exp (cond ((is? x expression)
			(cast expression x))
		       ((is? x interpreted-procedure-base)
			(source-expression (cast user-procedure x)))
		       (else
			null))))
	(if (not (or (null? exp)
		     (null? (source-file exp))
		     ))  ;(null? (defined-in exp))))
	    exp
	    null)))

    (define (eval-body ((array expression) exps) (environment env) (eval-stack estack))
      (public static object)
      (let ((end (- (length exps) 1)))
	(dotimes (i end)
	  (eval (vector-ref exps i)
		env
		estack))
	(if (> (length exps) 0)
	    (eval (vector-ref exps end)
		  env
		  estack)
	    null)))

    ;;
    ;; INSTANCE MEMBERS
    ;;
    (define exp-execution-mode "executionMode" (public "[NonSerialized]" execution-mode)
      (new execution-mode))
    (define source-file (public "[NonSerialized]" file-token) null)
    (define defined-in (public "[NonSerialized]" string) null)
    (define source-location (public "[NonSerialized]" integer) -1)
    (define enclosing-expression (public expression) null)
    (define property-table (private "[NonSerialized]" hashtable) null)
    (define declared-type "DeclaredType" (public "[NonSerialized]" clr-type) null)
    (define inferred-type "InferredType" (public "[NonSerialized]" clr-type) null)
    (define trace-analysis (public "[NonSerialized]" boolean) false)

    ;; Return the top-level expression of which this is a component
    (define (top-level-expression exp) (public property expression)
      (let ((e exp))
	(while (not (null? (enclosing-expression e)))
	  (set e (enclosing-expression e)))
	(return e)))

    ;; Return the source offset of this expression relative to its enclosing
    ;; top-level expression or -1 if its location isn't recorded.
    (define (source-offset exp) (public property integer)
      (let ((e exp))
	(while (and (not (null? (enclosing-expression e)))
		    (= (source-location e) -1))
	  (set e (enclosing-expression e)))
	(if (or (null? e)
		(= (source-location e) -1))
	    -1
	    (let ((tle (top-level-expression e)))
	      (if (null? tle)
		  -1
		  (- (source-location e)
		     (source-location tle)))))))

    (define (property e name) (public object)
      (if (null? (property-table e))
	  null
	  (gethash (property-table e) name)))

    (define (set-property! e name value) "SetProperty" (public void)
      (when (null? (property-table e))
	(set (property-table e) (new hashtable)))
      (set (gethash (property-table e) name)
	   value))

    (define (eval-preamble e (environment env)) (protected void)
      (when (not (check-normal (exp-execution-mode e)))
	(break e env)))

    (define (base-initializer this) (public void)
      (set (source-location this) -1)
      (set (source-file this) current-source-file)
      (set (defined-in this) current-source-definition))

    (define (simplify e (expression parent) (boolean tail-position?)) (public virtual expression)
      (set (enclosing-expression e) parent)
      e)

    (define (unparse e)
      (public abstract object)
      null)

    (define (subexpressions e) (public virtual property ilist)
      (cast ilist (new-array expression 0)))

    (define (eval e (environment env) (eval-stack estack))
      (public abstract object)
      #f)

    ;; We use this in lieu of the constructor
    (define (make-application (expression f)
			      ((array expression) args))
      (public static expression)
      (let ((l (length args))
	    (g (as f global-variable))
	    (r (as f member-reference)))
	(cond ((not (null? r))
	       (method-call r args))
	      ((and (not (null? g))
		    (or (null? (value g))
			(is? (value g)
			     interpreted-procedure)))
	       ;; Don't bother optimizing away the apply if we're just
	       ;; calling into an interpreted procedure anyway.
	       (application-general f args))
	      ((= l 0)
	       (application-0 f args))
	      ((= l 1)
	       (application-1 f args))
	      ((= l 2)
	       (application-2 f args))
	      ((= l 3)
	       (application-3 f args))
	      ((= l 4)
	       (application-4 f args))
	      ((= l 5)
	       (application-5 f args))
	      ((= l 6)
	       (application-6 f args))
	      ((= l 7)
	       (application-7 f args))
	      ((= l 8)
	       (application-8 f args))
	      ((= l 9)
	       (application-9 f args))
	      ((= l 10)
	       (application-10 f args))
	      (else
	       (application-general f args))))))

  (define-class body-expression expression
    ("[Serializable]")
    (define body (public (array expression)) null))

  ;;;
  ;;; ATOMIC EXPRESSIONS (CONSTANTS AND VARIABLES)
  ;;;

  (define-class (constant cvalue) expression
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define cvalue "value" (public object) null)

    (define (unparse c)
      (let ((v (cvalue c)))
	(if (or (is? v symbol)
		(is? v (array object)))
	    (new-array object 2 s-quote v)
	    (cvalue c))))
    (define (eval c env estack)
      (cvalue c)))

  (define-class (return-value-placeholder return-value enclosing-expression)
    expression
    ("[Serializable]")
    (define return-value (public object) null)

    (define (unparse p)
      (return-value p))

    (define (eval p e estack)
      #f))

  (define-class variable expression
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define vname "name" (public symbol) null)
    ;(define variable-type "type" (public clr-type) object)
    (define (unparse v)
      (vname v))
    (define (set-value! var (object v) (environment env)) (virtual public void)
      (void)))

  (define-class (global-variable-reference rvar enclosing-expression) variable
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define rvar "variable" (public global-variable) null)

    (define (unparse gvr)
      (unparse (rvar gvr)))

    (define (eval e env estack)
      (cond ((defined? (rvar e))
	     (value (rvar e)))
	    (else
	     (set-expression! estack e env)
	     (throw (undefined-variable-exception (rvar e)))))))
;	  (maybe-import (rvar e)))))

  ;;; A serialized reference to a global variable
  (define-class (global-ref) i-object-reference
    ("[Serializable]")
    (define gr-name "Name" (public string) null)
    (define gr-namespace "Namespace" (public namespace-base) null)

    (define (get-real-object gr context)
      (resolve-global (gr-namespace gr) (gr-name gr))))

  (define-class (global-variable vname gv-namespace) (variable "IDocumentable"
							       "System.Runtime.Serialization.ISerializable")
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define value (public object) missing-value)
    (define defined? "isDefined" (public boolean) false)
    (define constant? "isConstant" (public boolean) false)
    (define gv-namespace "Namespace" (public readonly namespace-base) null)
    (define variable-documentation
      "documentation" (public string) null)
    (define (set-value! e v env)
      (set (value e) v)
      (set (defined? e) true))

    (define (documentation v)
      (variable-documentation v))

    (define (get-object-data v info context)
      (set-type info (type->clr-type global-ref))
      (add-value info "Name" (pname (vname v)))
      (add-value info "Namespace" (gv-namespace v)))

    (define (define-global dv v (string doc)) "Define" (public void)
      (when (and (not (null? (value dv)))
		 (is? (value dv) generic-procedure)
		 (not (is? v generic-procedure)))
	(warn-redefining-generic-procedure dv))
      (set-value! dv v null)
      (unless (eq? doc null)
	(set (variable-documentation dv) doc)
	(let ((p (as v user-procedure)))
	  (when (and (not (eq? p null))
		     (eq? (documentation-kluge (cast i-documentable p)) null))
	    (set-documentation p doc))))
      (when (is? v procedure)
	(let ((p (cast procedure v)))
	  (when (null? (procedure-name (cast procedure v)))
	    (set (procedure-name p)
		 (vname dv)))
;			    (when (and (not (null? (variable-documentation dv)))
;				       (null? (documentation p)))
;			      (set (documentation p)
;				   (variable-documentation dv)))
	  (when (and (null? (variable-documentation dv))
		     (not (null? (documentation-kluge (cast i-documentable p)))))
	    (set (variable-documentation dv)
		 (documentation-kluge (cast i-documentable p)))))))

    (define (simplify gv parent tail?)
      (global-variable-reference gv parent))

    (define (eval e env estack)
      (if (defined? e)
	  (value e)
	  (throw (undefined-variable-exception e)))))
;	  (maybe-import e))))

  (define-class (local-variable vname declared-type default-value index snl) variable
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define default-value (public expression) null)
    (define index (public integer) 0)
    (define snl (public integer) 0)
    
    (define (optional? l) "IsOptional" (public property boolean)
      (not (null? (default-value l))))

    (define (eval local-var env estack)
      (env-lookup env (index local-var) (snl local-var)))

    (define (check-type local-var val) (public void)
      (let ((t (declared-type local-var)))
	(unless (or (null? val)
		    (null? t)
		    (eq? t (type->clr-type object))
		    (is-instance-of-type t val))
	  (throw (argument-type-exception (vname local-var)
					  val
					  (declared-type local-var))))))

    (define (set-value! local-var new-value env)
      (check-type local-var new-value)
      (env-set! env (index local-var) (snl local-var) new-value))

    (define (simplify e parent tail?)
      ;; Local variable references can't throw errors, so we don't need
      ;; track their enclosing expressions, and so we don't need to have
      ;; separate objects for each possible local variable reference.
      e))


  ;;;
  ;;; APPLICATIONS
  ;;;
  (define-class application expression
    ("[Serializable]")
    (define function (public expression) null)
    (define arguments (public (array expression)) null)

    (define (simplify a parent tail?)
      (let ((tail-mode optimize-tail-calls-kluge))
	(cond ((and tail?
		    (or (reference-equals? tail-mode s-all)
			(and (reference-equals? tail-mode s-self)
			     ;; See if it's a self-call
			     (or (and (is? (function a)
					   global-variable)
				      ;; KLUGE!
				      (eq? (pname (vname (cast global-variable
							       (function a))))
					   current-source-definition))
				 (and (is? (function a) local-variable)
				      (= (index (cast local-variable
						      (function a)))
					 -1))))))
	       (let ((new-call (simplify (tail-call (function a)
						    (arguments a))
					 parent
					 #f))) ; to prevent infinite recursion
		 (set (source-location new-call)
		      (source-location a))
		 new-call))
	      (else
	       (set (enclosing-expression a) parent)
	       (set (function a)
		    (simplify (function a)
			      a
			      #f))
	       (dotimes (i (length (arguments a)))
		 (set (vector-ref (arguments a) i)
		      (simplify (vector-ref (arguments a) i)
				a
				#f)))
	       a))))

    (define (unparse a)
      (let ((ar (arguments a)))
	(let ((up (new-array object (+ 1 (length ar)))))
	  (set (vector-ref up 0)
	       (unparse (function a)))
	  (dotimes (i (length ar))
	    (set (vector-ref up (+ i 1))
		 (unparse (vector-ref ar i))))
	  up)))

    (define (subexpressions a)
      (cons (function a)
	    (arguments a))))

  (define-class (application-general function arguments) application
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))

    (define (eval e env estack)
      ;; Set up stack frame
      (now-evaluating estack e env
	(eval-preamble e env)
	;; Determine function to evaluate
	(let ((op (eval (function e) env estack))
	      (args (new-array object (length (arguments e)))))
	  (unless (is? op procedure)
	    (throw! (bad-procedure-exception op)
		    e env))
	  ;; This is just so the unevaluated arguments say something
	  ;; meaningful when displayed in the debugger.
	  (copy-into (arguments e) args 0)
	  (let ((proc (cast procedure op)))
	    ;; Okay, now eval the arguments.
	    (dotimes (n (length args))
	      (set (vector-ref args n)
		   (eval (vector-ref (arguments e)
				     n)
			 env
			 estack)))
	    (set-expression! estack e env)
	    (let ((result (traced-apply proc estack args)))
	      (when (or (breakpointed-frame? estack)
			(not (check-normal-2 (exp-execution-mode e)
					     (proc-execution-mode proc))))
		(break (return-value-placeholder result e)
		       env))
	      result))))))
;	    ;; Pause if breaking.
;	    (when (and (breakpoint proc)
;		       ;; No point breaking if we already did.
;		       (not (or single-step-mode?
;				(breakpoint? e))))
;	      (break))
;	    ;; Do the application
;	    (let ((return-value (apply proc args)))
;	      ;; Show the return value, if necessary
;	      (when (or (breakpoint proc)
;			single-step-mode?
;			(breakpoint? e))
;		(push-eval-stack the-eval-stack
;				 (constant return-value)
;				 env)
;		(break)
;		(pop-eval-stack the-eval-stack))
;	      ;; return the return value.
;	      return-value))))))

  (define-class (tail-call-cookie) object
    ("[Serializable]"))

  (define-class (tail-call function arguments) application
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))

    (define the-tail-call-cookie (public static readonly object)
      (new tail-call-cookie))

    (define (is-the-tail-call-cookie? (object x))
      "IsTheTailCallCookie" (public static boolean)
      (eq? x the-tail-call-cookie))

    (define (eval e env estack)
      ;; Set up stack frame
      (now-evaluating estack e env
	(eval-preamble e env)
	;; Determine function to evaluate
	(let ((op (eval (function e) env estack))
	      (args (new-array object (length (arguments e)))))
	  (unless (is? op procedure)
	    (throw! (bad-procedure-exception op)
		    e env))
	  ;; This is just so the unevaluated arguments say something
	  ;; meaningful when displayed in the debugger.
	  (copy-into (arguments e) args 0)
	  (let ((proc (cast procedure op)))
	    ;; Okay, now eval the arguments.
	    (dotimes (n (length args))
	      (set (vector-ref args n)
		   (eval (vector-ref (arguments e)
				     n)
			 env
			 estack)))
	    ; Rewrite our stack frame
	    (reset-stack! estack proc args)
	    ; Tell the trampoline to call ourselves
	    the-tail-call-cookie)))))

  (make-application-class application-0
			  (traced-call0 proc))
  (make-application-class application-1
			  (traced-call1 proc 0))
  (make-application-class application-2
			  (traced-call2 proc 0 1))
  (make-application-class application-3
			  (traced-call3 proc 0 1 2))
  (make-application-class application-4
			  (traced-call4 proc 0 1 2 3))
  (make-application-class application-5
			  (traced-call5 proc 0 1 2 3 4))
  (make-application-class application-6
			  (traced-call6 proc 0 1 2 3 4 5))
  (make-application-class application-7
			  (traced-call7 proc 0 1 2 3 4 5 6))
  (make-application-class application-8
			  (traced-call8 proc 0 1 2 3 4 5 6 7))
  (make-application-class application-9
			  (traced-call9 proc 0 1 2 3 4 5 6 7 8))
  (make-application-class application-10
			  (traced-call10 proc 0 1 2 3 4 5 6 7 8 9))
  )
